home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / flic / invariant.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  3.1 KB  |  92 lines  |  [TEXT/CCL2]
  1. ;;; invariant.scm -- look for invariant expressions
  2. ;;;
  3. ;;; author :  Sandra Loosemore
  4. ;;; date   :  12 Mar 1993
  5. ;;;
  6. ;;;
  7. ;;; The function flic-invariant? returns true if the expression is
  8. ;;; invariant with respect to a set of local variable bindings.
  9.  
  10. (define-flic-walker flic-invariant? (object local-bindings))
  11.  
  12. (define (flic-invariant-list? objects local-bindings)
  13.   (if (null objects)
  14.       '#t
  15.       (and (flic-invariant? (car objects) local-bindings)
  16.        (flic-invariant-list? (cdr objects) local-bindings))))
  17.  
  18. (define-flic-invariant? flic-lambda (object local-bindings)
  19.   (flic-invariant? (flic-lambda-body object)
  20.            (cons (flic-lambda-vars object) local-bindings)))
  21.  
  22. (define-flic-invariant? flic-let (object local-bindings)
  23.   (let* ((bindings      (flic-let-bindings object))
  24.      (body          (flic-let-body object))
  25.      (recursive?    (flic-let-recursive? object))
  26.      (inner-stuff   (cons bindings local-bindings)))
  27.     (and (flic-invariant-list? (map (function var-value) bindings)
  28.                    (if recursive? inner-stuff local-bindings))
  29.      (flic-invariant? body inner-stuff))))
  30.  
  31. (define-flic-invariant? flic-app (object local-bindings)
  32.   (and (flic-invariant? (flic-app-fn object) local-bindings)
  33.        (flic-invariant-list? (flic-app-args object) local-bindings)))
  34.  
  35. (define-flic-invariant? flic-ref (object local-bindings)
  36.   (let ((var  (flic-ref-var object)))
  37.     (or (var-toplevel? var)
  38.     (flic-local-var? var local-bindings))))
  39.  
  40. (define (flic-local-var? var local-bindings)
  41.   (cond ((null? local-bindings)
  42.      '#f)
  43.     ((memq var (car local-bindings))
  44.      '#t)
  45.     (else
  46.      (flic-local-var? var (cdr local-bindings)))))
  47.  
  48. (define-flic-invariant? flic-const (object local-bindings)
  49.   (declare (ignore object local-bindings))
  50.   '#t)
  51.  
  52. (define-flic-invariant? flic-pack (object local-bindings)
  53.   (declare (ignore object local-bindings))
  54.   '#t)
  55.  
  56. (define-flic-invariant? flic-case-block (object local-bindings)
  57.   (flic-invariant-list? (flic-case-block-exps object) local-bindings))
  58.  
  59. (define-flic-invariant? flic-return-from (object local-bindings)
  60.   (flic-invariant? (flic-return-from-exp object) local-bindings))
  61.  
  62. (define-flic-invariant? flic-and (object local-bindings)
  63.   (flic-invariant-list? (flic-and-exps object) local-bindings))
  64.  
  65. (define-flic-invariant? flic-if (object local-bindings)
  66.   (and (flic-invariant? (flic-if-test-exp object) local-bindings)
  67.        (flic-invariant? (flic-if-then-exp object) local-bindings)
  68.        (flic-invariant? (flic-if-else-exp object) local-bindings)))
  69.  
  70. (define-flic-invariant? flic-sel (object local-bindings)
  71.   (flic-invariant? (flic-sel-exp object) local-bindings))
  72.  
  73. (define-flic-invariant? flic-is-constructor (object local-bindings)
  74.   (flic-invariant? (flic-is-constructor-exp object) local-bindings))
  75.  
  76. (define-flic-invariant? flic-con-number (object local-bindings)
  77.   (flic-invariant? (flic-con-number-exp object) local-bindings))
  78.  
  79. (define-flic-invariant? flic-void (object local-bindings)
  80.   (declare (ignore object local-bindings))
  81.   '#t)
  82.  
  83. (define-flic-invariant? flic-update (object local-bindings)
  84.   (and (flic-invariant-list? (map (function cdr) (flic-update-slots object))
  85.                  local-bindings)
  86.        (flic-invariant? (flic-update-exp object) local-bindings)))
  87.  
  88.  
  89.     
  90.  
  91.  
  92.